home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Graphics Programming (2nd Edition) / Visual Basic Graphics Programming 2nd Edition.iso / Src / Ch8 / Bounce2b.frm (.txt) < prev    next >
Visual Basic Form  |  1999-05-28  |  10KB  |  281 lines
  1. VERSION 5.00
  2. Begin VB.Form frmBounce2b 
  3.    Caption         =   "Bounce2b"
  4.    ClientHeight    =   5235
  5.    ClientLeft      =   1320
  6.    ClientTop       =   825
  7.    ClientWidth     =   6870
  8.    LinkTopic       =   "Form1"
  9.    PaletteMode     =   1  'UseZOrder
  10.    ScaleHeight     =   349
  11.    ScaleMode       =   3  'Pixel
  12.    ScaleWidth      =   458
  13.    Begin VB.PictureBox picHidden 
  14.       Height          =   495
  15.       Index           =   0
  16.       Left            =   480
  17.       ScaleHeight     =   435
  18.       ScaleWidth      =   555
  19.       TabIndex        =   6
  20.       Top             =   240
  21.       Visible         =   0   'False
  22.       Width           =   615
  23.    End
  24.    Begin VB.TextBox txtFramesPerSecond 
  25.       Height          =   285
  26.       Left            =   1440
  27.       TabIndex        =   4
  28.       Text            =   "20"
  29.       Top             =   4920
  30.       Width           =   375
  31.    End
  32.    Begin VB.TextBox txtNumBalls 
  33.       Height          =   285
  34.       Left            =   1440
  35.       TabIndex        =   3
  36.       Text            =   "20"
  37.       Top             =   4560
  38.       Width           =   375
  39.    End
  40.    Begin VB.CommandButton cmdStart 
  41.       Caption         =   "Start"
  42.       Default         =   -1  'True
  43.       Height          =   495
  44.       Left            =   2160
  45.       TabIndex        =   1
  46.       Top             =   4620
  47.       Width           =   855
  48.    End
  49.    Begin VB.PictureBox picCourt 
  50.       AutoRedraw      =   -1  'True
  51.       Height          =   4455
  52.       Left            =   0
  53.       ScaleHeight     =   293
  54.       ScaleMode       =   3  'Pixel
  55.       ScaleWidth      =   453
  56.       TabIndex        =   0
  57.       Top             =   0
  58.       Width           =   6855
  59.    End
  60.    Begin VB.Label Label1 
  61.       Caption         =   "Frames per second:"
  62.       Height          =   255
  63.       Index           =   0
  64.       Left            =   0
  65.       TabIndex        =   5
  66.       Top             =   4920
  67.       Width           =   1455
  68.    End
  69.    Begin VB.Label Label1 
  70.       Caption         =   "Number of balls:"
  71.       Height          =   255
  72.       Index           =   1
  73.       Left            =   0
  74.       TabIndex        =   2
  75.       Top             =   4560
  76.       Width           =   1455
  77.    End
  78. Attribute VB_Name = "frmBounce2b"
  79. Attribute VB_GlobalNameSpace = False
  80. Attribute VB_Creatable = False
  81. Attribute VB_PredeclaredId = True
  82. Attribute VB_Exposed = False
  83. Option Explicit
  84. Private xmax As Integer
  85. Private ymax As Integer
  86. Private NumBalls As Integer
  87. Private BallX() As Integer
  88. Private BallY() As Integer
  89. Private BallDx() As Integer
  90. Private BallDy() As Integer
  91. Private BallRadius() As Integer
  92. Private BallColor() As Long
  93. Private Playing As Boolean
  94. Private NumPlayed As Long
  95. Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
  96. ' Draw some random rectangles on the bacground.
  97. Private Sub DrawBackground()
  98. Dim i As Integer
  99. Dim wid As Single
  100. Dim hgt As Single
  101.     ' Start with a clean slate.
  102.     picCourt.Line (0, 0)-(picCourt.ScaleWidth, picCourt.ScaleHeight), picCourt.BackColor, BF
  103.     ' Draw some rectangles.
  104.     For i = 1 To 10
  105.         hgt = 10 + Rnd * xmax / 3
  106.         wid = 10 + Rnd * ymax / 3
  107.         picCourt.Line (Int(Rnd * xmax), Int(Rnd * ymax))-Step(hgt, wid), QBColor(Int(Rnd * 16)), BF
  108.     Next i
  109.     ' Make the rectangles part of the permanent background.
  110.     picCourt.Picture = picCourt.Image
  111. End Sub
  112. ' Generate some random data.
  113. Private Sub InitData()
  114. Dim ball As Integer
  115. Dim R As Integer
  116. Dim clr As Integer
  117.     ' See how many balls there should be.
  118.     If Not IsNumeric(txtNumBalls.Text) Then _
  119.         txtNumBalls.Text = "10"
  120.     NumBalls = CInt(txtNumBalls.Text)
  121.     ReDim BallRadius(1 To NumBalls)
  122.     ReDim BallX(1 To NumBalls)
  123.     ReDim BallY(1 To NumBalls)
  124.     ReDim BallDx(1 To NumBalls)
  125.     ReDim BallDy(1 To NumBalls)
  126.     ReDim BallColor(1 To NumBalls)
  127.     ' Set the initial ball data.
  128.     For ball = 1 To NumBalls
  129.         R = Int(10 * Rnd + 5)
  130.         BallRadius(ball) = R
  131.         BallX(ball) = Int((xmax - R + 1) * Rnd)
  132.         BallY(ball) = Int((ymax - R + 1) * Rnd)
  133.         BallDx(ball) = Int(21 * Rnd - 10)
  134.         BallDy(ball) = Int(21 * Rnd - 10)
  135.         clr = Int(15 * Rnd)
  136.         If clr >= 7 Then clr = clr + 1
  137.         BallColor(ball) = QBColor(clr)
  138.         ' Create a hidden PictureBox for this ball.
  139.         If ball > picHidden.UBound Then
  140.             Load picHidden(ball)
  141.         End If
  142.         ' Make the picture big enough.
  143.         picHidden(ball).Width = 2 * BallRadius(ball) + 4
  144.         picHidden(ball).Height = 2 * BallRadius(ball) + 4
  145.     Next ball
  146.     ' Unload any hidden PictureBoxes we no longer need.
  147.     For ball = NumBalls + 1 To picHidden.UBound
  148.         Unload picHidden(ball)
  149.     Next ball
  150. End Sub
  151. ' Start the animation.
  152. Private Sub cmdStart_Click()
  153.     If Playing Then
  154.         Playing = False
  155.         cmdStart.Caption = "Stopped"
  156.         cmdStart.Enabled = False
  157.     Else
  158.         cmdStart.Caption = "Stop"
  159.         Playing = True
  160.         InitData
  161.         PlayData
  162.         Playing = False
  163.         cmdStart.Caption = "Start"
  164.         cmdStart.Enabled = True
  165.     End If
  166. End Sub
  167. ' Play the animation.
  168. Private Sub PlayData()
  169. Dim ms_per_frame As Long
  170. Dim start_time As Single
  171. Dim stop_time As Single
  172.     ' Draw a random background.
  173.     DrawBackground
  174.     ' See how fast we should go.
  175.     If Not IsNumeric(txtFramesPerSecond.Text) Then _
  176.         txtFramesPerSecond.Text = "10"
  177.     ms_per_frame = 1000 \ CLng(txtFramesPerSecond.Text)
  178.     ' Start the animation.
  179.     NumPlayed = 0
  180.     start_time = Timer
  181.     PlayImages ms_per_frame
  182.     ' Display results.
  183.     stop_time = Timer
  184.     MsgBox "Displayed" & Str$(NumPlayed) & _
  185.         " frames in " & _
  186.         Format$(stop_time - start_time, "0.00") & _
  187.         " seconds (" & _
  188.         Format$(NumPlayed / (stop_time - start_time), "0.00") & _
  189.         " FPS)."
  190. End Sub
  191. ' Play the animation.
  192. Private Sub PlayImages(ByVal ms_per_frame As Long)
  193. Dim ball As Integer
  194. Dim next_time As Long
  195.     ' Get the current time.
  196.     next_time = GetTickCount()
  197.     ' Start the animation.
  198.     Do While Playing
  199.         NumPlayed = NumPlayed + 1
  200.         ' Save the background where the balls
  201.         ' will be placed.
  202.         For ball = 1 To NumBalls
  203.             BitBlt picHidden(ball).hDC, _
  204.                 0, 0, _
  205.                 2 * BallRadius(ball) + 4, _
  206.                 2 * BallRadius(ball) + 4, _
  207.                 picCourt.hDC, _
  208.                 BallX(ball) - BallRadius(ball) - 2, _
  209.                 BallY(ball) - BallRadius(ball) - 2, _
  210.                 vbSrcCopy
  211.             picHidden(ball).Picture = picHidden(ball).Image
  212.         Next ball
  213.         ' Draw the balls.
  214.         For ball = 1 To NumBalls
  215.             picCourt.FillColor = BallColor(ball)
  216.             picCourt.Circle _
  217.                 (BallX(ball), BallY(ball)), _
  218.                 BallRadius(ball), BallColor(ball)
  219.         Next ball
  220.         ' Wait until it's time for the next frame.
  221.         next_time = next_time + ms_per_frame
  222.         WaitTill next_time
  223.         ' Restore the background information.
  224.         For ball = 1 To NumBalls
  225.             BitBlt picCourt.hDC, _
  226.                 BallX(ball) - BallRadius(ball) - 2, _
  227.                 BallY(ball) - BallRadius(ball) - 2, _
  228.                 2 * BallRadius(ball) + 4, _
  229.                 2 * BallRadius(ball) + 4, _
  230.                 picHidden(ball).hDC, _
  231.                 0, 0, _
  232.                 vbSrcCopy
  233.         Next ball
  234.         ' Move the balls for the next frame,
  235.         ' keeping them within picCourt.
  236.         For ball = 1 To NumBalls
  237.             BallX(ball) = BallX(ball) + BallDx(ball)
  238.             If BallX(ball) < BallRadius(ball) Then
  239.                 BallX(ball) = 2 * BallRadius(ball) - BallX(ball)
  240.                 BallDx(ball) = -BallDx(ball)
  241.             ElseIf BallX(ball) > xmax - BallRadius(ball) Then
  242.                 BallX(ball) = 2 * (xmax - BallRadius(ball)) - BallX(ball)
  243.                 BallDx(ball) = -BallDx(ball)
  244.             End If
  245.             BallY(ball) = BallY(ball) + BallDy(ball)
  246.             If BallY(ball) < BallRadius(ball) Then
  247.                 BallY(ball) = 2 * BallRadius(ball) - BallY(ball)
  248.                 BallDy(ball) = -BallDy(ball)
  249.             ElseIf BallY(ball) > ymax - BallRadius(ball) Then
  250.                 BallY(ball) = 2 * (ymax - BallRadius(ball)) - BallY(ball)
  251.                 BallDy(ball) = -BallDy(ball)
  252.             End If
  253.         Next ball
  254.         If Not Playing Then Exit Do
  255.     Loop
  256. End Sub
  257. Private Sub Form_Load()
  258.     Randomize
  259.     picCourt.FillStyle = vbSolid
  260.     picCourt.ScaleMode = vbPixels
  261.     With picHidden(0)
  262.         .AutoRedraw = True
  263.         .Visible = False
  264.         .ScaleMode = vbPixels
  265.         .BorderStyle = vbBSNone
  266.     End With
  267. End Sub
  268. ' Make the ball court nice and big.
  269. Private Sub Form_Resize()
  270. Const GAP = 3
  271.     txtFramesPerSecond.Top = ScaleHeight - GAP - txtFramesPerSecond.Height
  272.     Label1(0).Top = txtFramesPerSecond.Top
  273.     txtNumBalls.Top = txtFramesPerSecond.Top - GAP - txtNumBalls.Height
  274.     Label1(1).Top = txtNumBalls.Top
  275.     cmdStart.Top = (txtNumBalls.Top + txtFramesPerSecond.Top + txtFramesPerSecond.Height - cmdStart.Height) / 2
  276.     picCourt.Move 0, 0, ScaleWidth, txtNumBalls.Top - GAP
  277.     xmax = picCourt.ScaleWidth - 1
  278.     ymax = picCourt.ScaleHeight - 1
  279.     picCourt.Picture = picCourt.Image
  280. End Sub
  281.